home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmploc.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
9KB
|
245 lines
;;; CMPLOC Set-loc and Wt-loc.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(defvar *value-to-go*)
;;; Valid locations are:
;;; NIL
;;; T
;;; 'FUN-VAL'
;;; ( 'VS' vs-address )
;;; ( 'VS*' vs-address )
;;; ( 'CCB-VS' ccb-vs )
;;; ( 'VAR' var-object ccb )
;;; ( 'VV' vv-index )
;;; ( 'CVAR' cvar )
;;; ( 'INLINE' side-effect-p fun/string locs )
;;; ( 'INLINE-COND' side-effect-p fun/string locs )
;;; ( 'INLINE-FIXNUM' side-effect-p fun/string locs )
;;; ( 'INLINE-CHARACTER' side-effect-p fun/string locs )
;;; ( 'INLINE-LONG-FLOAT' side-effect-p fun/string locs )
;;; ( 'INLINE-SHORT-FLOAT' side-effect-p fun/string locs )
;;; ( 'SIMPLE-CALL { SYMLISPCALL-NO-EVENT
;;; | LISPCALL-NO-EVENT
;;; | SYMLISPCALL
;;; | LISPCALL }
;;; vs-index number-of-arguments [ vv-index ] )
;;; ( 'VS-BASE' offset )
;;; ( 'CAR' cvar )
;;; ( 'CADR' cvar )
;;; ( 'SYMBOL-FUNCTION' vv-index )
;;; ( 'MAKE-CCLOSURE' cfun cllink )
;;; ( 'FIXNUM-VALUE' vv-index fixnum-value )
;;; ( 'FIXNUM-LOC' loc )
;;; ( 'CHARACTER-VALUE' vv-index character-code )
;;; ( 'CHARACTER-LOC' loc )
;;; ( 'LONG-FLOAT-VALUE' vv-index long-float-value )
;;; ( 'LONG-FLOAT-LOC' loc )
;;; ( 'SHORT-FLOAT-VALUE' vv-index short-float-value )
;;; ( 'SHORT-FLOAT-LOC' loc )
;;; Valid *value-to-go* locations are:
;;;
;;; 'RETURN' The value is returned from the current function.
;;; 'RETURN-FIXNUM'
;;; 'RETURN-CHARACTER'
;;; 'RETURN-LONG-FLOAT'
;;; 'RETURN-SHORT-FLOAT'
;;; 'RETURN-OBJECT
;;; 'TRASH' The value may be thrown away.
;;; 'TOP' The value should be set at the top of vs as if it were
;;; a resulted value of a function call.
;;; ( 'VS' vs-address )
;;; ( 'VS*' vs-address )
;;; ( 'CCB-VS' ccb-vs )
;;; ( 'VAR' var-object ccb )
;;; ( 'JUMP-TRUE' label )
;;; ( 'JUMP-FALSE' label )
;;; ( 'BDS-BIND' vv-index )
;;; ( 'PUSH-CATCH-FRAME' )
;;; ( 'DBIND' symbol-name-vv )
(si:putprop 'cvar 'wt-cvar 'wt-loc)
(si:putprop 'vv 'wt-vv 'wt-loc)
(si:putprop 'car 'wt-car 'wt-loc)
(si:putprop 'cdr 'wt-cdr 'wt-loc)
(si:putprop 'cadr 'wt-cadr 'wt-loc)
(si:putprop 'vs-base 'wt-vs-base 'wt-loc)
(si:putprop 'fixnum-value 'wt-fixnum-value 'wt-loc)
(si:putprop 'fixnum-loc 'wt-fixnum-loc 'wt-loc)
(si:putprop 'character-value 'wt-character-value 'wt-loc)
(si:putprop 'character-loc 'wt-character-loc 'wt-loc)
(si:putprop 'long-float-value 'wt-long-float-value 'wt-loc)
(si:putprop 'long-float-loc 'wt-long-float-loc 'wt-loc)
(si:putprop 'short-float-value 'wt-short-float-value 'wt-loc)
(si:putprop 'short-float-loc 'wt-short-float-loc 'wt-loc)
(defun set-loc (loc &aux fd)
(cond ((eq *value-to-go* 'return) (set-return loc))
((eq *value-to-go* 'trash)
(cond ((and (consp loc)
(member (car loc)
'(INLINE INLINE-COND INLINE-FIXNUM
INLINE-CHARACTER INLINE-LONG-FLOAT
INLINE-SHORT-FLOAT))
(cadr loc))
(wt-nl "(void)(") (wt-inline t (caddr loc) (cadddr loc))
(wt ");"))
((and (consp loc) (eq (car loc) 'SIMPLE-CALL))
(wt-nl "(void)" loc ";"))))
((eq *value-to-go* 'top)
(unless (eq loc 'fun-val) (set-top loc)))
((eq *value-to-go* 'return-fixnum) (set-return-fixnum loc))
((eq *value-to-go* 'return-character) (set-return-character loc))
((eq *value-to-go* 'return-long-float) (set-return-long-float loc))
((eq *value-to-go* 'return-short-float) (set-return-short-float loc))
((or (not (consp *value-to-go*))
(not (symbolp (car *value-to-go*))))
(baboon))
((setq fd (get (car *value-to-go*) 'set-loc))
(apply fd loc (cdr *value-to-go*)))
((setq fd (get (car *value-to-go*) 'wt-loc))
(wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";"))
(t (baboon)))
)
(defun wt-loc (loc)
(cond ((eq loc nil) (wt "Cnil"))
((eq loc t) (wt "Ct"))
((eq loc 'fun-val) (wt "vs_base[0]"))
((or (not (consp loc))
(not (symbolp (car loc))))
(baboon))
(t (let ((fd (get (car loc) 'wt-loc)))
(when (null fd) (baboon))
(apply fd (cdr loc)))))
)
(defun set-return (loc)
(cond ((eq loc 'fun-val))
((and (consp loc) (eq (car loc) 'vs) (= (caadr loc) *level*))
(wt-nl "vs_top=(vs_base=base+" (cdadr loc) ")+1;")
(base-used))
((and (consp loc)
(eq (car loc) 'var)
(eq (var-kind (cadr loc)) 'LEXICAL)
(not (var-ref-ccb (cadr loc)))
(= (car (var-ref (cadr loc))) *level*))
(wt-nl "vs_top=(vs_base=base+" (cdr (var-ref (cadr loc))) ")+1;")
(base-used))
(t (set-top loc)))
)
(defun set-top (loc)
(let ((*vs* *vs*))
(wt-nl) (wt-vs (vs-push)) (wt "= " loc ";")
(wt-nl "vs_top=(vs_base=base+" (1- *vs*) ")+1;")
(base-used)))
(defun wt-vs-base (offset) (wt "vs_base[" offset "]"))
(defun wt-car (cvar) (wt "(V" cvar "->c.c_car)"))
(defun wt-cdr (cvar) (wt "(V" cvar "->c.c_cdr)"))
(defun wt-cadr (cvar) (wt "(V" cvar "->c.c_cdr->c.c_car)"))
(defun wt-cvar (cvar) (wt "V" cvar))
(defun wt-vv (vv) (wt "VV[" vv "]"))
(defun wt-fixnum-loc (loc)
(cond ((and (consp loc)
(eq (car loc) 'var)
(eq (var-kind (cadr loc)) 'FIXNUM))
(wt "V" (var-loc (cadr loc))))
((and (consp loc) (eq (car loc) 'INLINE-FIXNUM))
(wt-inline-loc (caddr loc) (cadddr loc)))
((and (consp loc) (eq (car loc) 'fixnum-value))
(wt (caddr loc)))
(t (wt "fix(" loc ")"))))
(defun fixnum-loc-p (loc)
(and (consp loc)
(or (and (eq (car loc) 'var)
(eq (var-kind (cadr loc)) 'FIXNUM))
(eq (car loc) 'INLINE-FIXNUM)
(eq (car loc) 'fixnum-value))))
(defun wt-fixnum-value (vv fixnum-value)
(declare (ignore fixnum-value))
(wt "VV[" vv "]"))
(defun wt-character-loc (loc)
(cond ((and (consp loc)
(eq (car loc) 'var)
(eq (var-kind (cadr loc)) 'CHARACTER))
(wt "V" (var-loc (cadr loc))))
((and (consp loc) (eq (car loc) 'INLINE-CHARACTER))
(wt-inline-loc (caddr loc) (cadddr loc)))
((and (consp loc) (eq (car loc) 'CHARACTER-VALUE))
(wt (caddr loc)))
(t (wt "char_code(" loc ")"))))
(defun character-loc-p (loc)
(and (consp loc)
(or (and (eq (car loc) 'var)
(eq (var-kind (cadr loc)) 'CHARACTER))
(eq (car loc) 'INLINE-CHARACTER)
(eq (car loc) 'character-value))))
(defun wt-character-value (vv character-code)
(declare (ignore character-code))
(wt "VV[" vv "]"))
(defun wt-long-float-loc (loc)
(cond ((and (consp loc)
(eq (car loc) 'var)
(eq (var-kind (cadr loc)) 'LONG-FLOAT))
(wt "V" (var-loc (cadr loc))))
((and (consp loc) (eq (car loc) 'INLINE-LONG-FLOAT))
(wt-inline-loc (caddr loc) (cadddr loc)))
((and (consp loc) (eq (car loc) 'long-float-value))
(wt (caddr loc)))
(t (wt "lf(" loc ")"))))
(defun long-float-loc-p (loc)
(and (consp loc)
(or (and (eq (car loc) 'var)
(eq (var-kind (cadr loc)) 'LONG-FLOAT))
(eq (car loc) 'INLINE-LONG-FLOAT)
(eq (car loc) 'long-float-value))))
(defun wt-long-float-value (vv long-float-value)
(declare (ignore long-float-value))
(wt "VV[" vv "]"))
(defun wt-short-float-loc (loc)
(cond ((and (consp loc)
(eq (car loc) 'var)
(eq (var-kind (cadr loc)) 'SHORT-FLOAT))
(wt "V" (var-loc (cadr loc))))
((and (consp loc) (eq (car loc) 'INLINE-SHORT-FLOAT))
(wt-inline-loc (caddr loc) (cadddr loc)))
((and (consp loc) (eq (car loc) 'short-float-value))
(wt (caddr loc)))
(t (wt "sf(" loc ")"))))
(defun short-float-loc-p (loc)
(and (consp loc)
(or (and (eq (car loc) 'var)
(eq (var-kind (cadr loc)) 'SHORT-FLOAT))
(eq (car loc) 'INLINE-SHORT-FLOAT)
(eq (car loc) 'short-float-value))))
(defun wt-short-float-value (vv short-float-value)
(declare (ignore short-float-value))
(wt "VV[" vv "]"))